MacFormat 1995 April/macformat-023.iso/Shareware City/Developers/ICProgKit1.0/Source/API Source/ICRAPI.p

Text File | 1994-11-27 | 16.0 KB | 581 lines | [TEXT/PJMM]

unit ICRAPI;

interface

    uses
{$ifc undefined THINK_Pascal}
        Types, Files,
{$endc}
        Components, ICTypes;

    type
        ICRRecord = record                    (* this is *completely* private to the implementation!!! *)
                instance: ComponentInstance;        (* nil if no component available, if not nil then rest of record is junk *)
                have_config_file: boolean;
                config_file: FSSpec;
                config_refnum: integer;
                perm: ICPerm;
                inside_begin: boolean;
                default_filename: Str63;
            end;
        ICRRecordPtr = ^ICRRecord;

    function ICRStart (var inst: ICRRecord; creator: OSType): ICError;
    function ICRStop (var inst: ICRRecord): ICError;

    function ICRFindConfigFile (var inst: ICRRecord; count: integer; folders: ICDirSpecArrayPtr): ICError;
    function ICRSpecifyConfigFile (var inst: ICRRecord; config: FSSpec): ICError;

    function ICRGetSeed (var inst: ICRRecord; var seed: longint): ICError;
    function ICRGetPerm (var inst: ICRRecord; var perm: ICPerm): ICError;

    function ICRBegin (var inst: ICRRecord; perm: ICPerm): ICError;
    function ICRGetPref (var inst: ICRRecord; key: Str255; var attr: ICAttr; buf: Ptr; var size: longint): ICError;
    function ICRSetPref (var inst: ICRRecord; key: Str255; attr: ICAttr; buf: Ptr; size: longint): ICError;
    function ICRCountPref (var inst: ICRRecord; var count: longint): ICError;
    function ICRGetIndPref (var inst: ICRRecord; n: longint; var key: Str255): ICError;
    function ICRDeletePref (var inst: ICRRecord; key: Str255): ICError;
    function ICREnd (var inst: ICRRecord): ICError;
    function ICRDefaultFileName (var inst: ICRRecord; var name: Str63): ICError;

implementation

    uses
{$ifc undefined THINK_Pascal}
        Resources, GestaltEqu, OSUtils, Memory, Errors,
{$endc}
        Aliases, AppleTalk, Folders;

    function ICFindFolder(vRefNum: integer; folderType: OSType; createFolder: boolean;
                                                 var foundVRefNum: integer; var foundDirID: longint): OSErr;
         inline $7000,$A823;

    const
        Res_Code = 'ICRP';

    function ICRStart (var inst: ICRRecord; creator: OSType): ICError;
        var
            junk: ICError;
    begin
        inst.have_config_file := false;
        inst.config_file.vRefNum := 0;
        inst.config_file.parID := 0;
        inst.config_file.name := '';
        inst.config_refnum := 0;
        inst.perm := icNoPerm;
        junk := ICRDefaultFileName(inst, inst.default_filename);
        ICRStart := noErr;
    end; (* ICRStart *)

    procedure ICRCloseIfOpen (var inst: ICRRecord);
    begin
        if inst.config_refnum <> 0 then begin
            CloseResFile(inst.config_refnum);
            inst.config_refnum := 0;
        end; (* if *)
        inst.perm := icNoPerm;
    end; (* ICRCloseIfOpen *)

    function ICRStop (var inst: ICRRecord): ICError;
    begin
        ICRCloseIfOpen(inst);
        ICRStop := noErr;
    end; (* ICRStop *)

    function ICRFindConfigFile (var inst: ICRRecord; count: integer; folders: ICDirSpecArrayPtr): ICError;

        function FindPrefFolder (var pref_fold: ICDirSpec): OSErr;
            var
                err: OSErr;
                env: SysEnvRec;
                junk: longint;
                response: longint;
        begin
            if (Gestalt(gestaltFindFolderAttr, response) = noErr) & btst(response, gestaltFindFolderPresent) then begin
                (* Gestalt says it's implemented -- call it directly *)
                err := ICFindFolder(kOnSystemDisk, kPreferencesFolderType, true, pref_fold.vRefNum, pref_fold.dirID);
            end
            else begin
                (* Simulate the important stuff *)
                err := SysEnvirons(curSysEnvVers, env);
                if err = noErr then begin
                    err := GetWDInfo(env.sysVRefNum, pref_fold.vRefNum, pref_fold.dirID, junk);
                end; (* if *)
            end; (* if *)
            FindPrefFolder := err;
        end; (* FindPrefFolder *)

        function ScanFolder (folder: ICDirSpec; var found_file: FSSpec): boolean;

            function FoundFile (folder: ICDirSpec; ndx: integer; var found_file: FSSpec): OSErr;
                var
                    err: OSErr;
                    cpb: CInfoPBRec;
                    is_folder: boolean;
                    was_alias: boolean;
                    response: longint;
            begin
                with cpb do begin (* safe *)
                    ioVRefNum := folder.vRefNum;
                    ioDirID := folder.dirID;
                    ioNamePtr := @found_file.name;
                    ioFDirIndex := ndx;
                    err := PBGetCatInfoSync(@cpb);
                    if err = noErr then begin
                        found_file.vRefNum := cpb.ioVRefNum;
                        found_file.parID := cpb.ioFlParID;
                        if (btst(cpb.ioFlAttrib, 4) or (cpb.ioFlFndrInfo.fdType <> ICfiletype)) then begin
                            err := 1;
                        end
                        else if (Gestalt(gestaltAliasMgrAttr, response) = noErr) & btst(response, gestaltAliasMgrPresent) then begin
                            err := ResolveAliasFile(found_file, true, is_folder, was_alias);
                            if err <> noErr then begin
                                err := 1;
                            end; (* if *)
                        end; (* if *)
                    end; (* if *)
                end; (* with *)
                FoundFile := err;
            end; (* FoundFile *)

            var
                err: ICError;
                found: boolean;
                i: integer;
        begin
            found_file.name := inst.default_filename;
            found := (FoundFile(folder, 0, found_file) = noErr);
            if not found then begin
                i := 1;
                repeat
                    found_file.name := '';
                    err := FoundFile(folder, i, found_file);
                    i := i + 1;
                until err <> 1;
                found := (err = noErr);
            end; (* if *)
            ScanFolder := found;
        end; (* ScanFolder *)

        var
            err: ICError;
            i: integer;
            found: boolean;
            pref_fold: ICDirSpec;
    begin
        ICRCloseIfOpen(inst);                { ! }
        err := noErr;
        i := 0;
        found := false;
        while (i < count) and not found do begin
            found := ScanFolder(folders^[i], inst.config_file);
            i := i + 1;
        end; (* while *)
        if not found then begin
            err := FindPrefFolder(pref_fold);
            if (err = noErr) & not ScanFolder(pref_fold, inst.config_file) then begin
                inst.config_file.vRefNum := pref_fold.vRefNum;
                inst.config_file.parID := pref_fold.dirID;
                inst.config_file.name := inst.default_filename;
            end; (* if *)
        end; (* if *)
        inst.have_config_file := err = noErr;
        ICRFindConfigFile := err;
    end; (* ICRFindConfigFile *)

    function ICRSpecifyConfigFile (var inst: ICRRecord; config: FSSpec): ICError;
    begin
        ICRCloseIfOpen(inst);                { ! }
        inst.have_config_file := true;
        inst.config_file := config;
        ICRSpecifyConfigFile := noErr;
    end; (* ICRSpecifyConfigFile *)

    function ICRGetSeed (var inst: ICRRecord; var seed: longint): ICError;
        var
            err: ICError;
            cpb: CInfoPBRec;
    begin
        seed := 0;
        err := fnfErr;
        if inst.have_config_file then begin
            with cpb do begin (* safe *)
                ioVRefNum := inst.config_file.vRefNum;
                ioDirID := inst.config_file.parID;
                ioNamePtr := @inst.config_file.name;
                ioFDirIndex := 0;
            end; (* with *)
            err := PBGetCatInfoSync(@cpb);
            if err = noErr then begin
                seed := cpb.ioFlMdDat;
            end
            else if err = fnfErr then begin
                err := noErr;
            end; (* if *)
        end; (* if *)
        ICRGetSeed := err;
    end; (* ICRGetSeed *)

    function ICRGetPerm (var inst: ICRRecord; var perm: ICPerm): ICError;
    begin
        perm := inst.perm;
        ICRGetPerm := noErr;
    end; (* ICRGetPerm *)

    function ICRPermToFSPerm (perm: ICPerm): integer;
    begin
        case perm of
            icReadOnlyPerm:
                ICRPermToFSPerm := fsRdPerm;
            icReadWritePerm:
                ICRPermToFSPerm := fsRdWrPerm;
        otherwise
            ICRPermToFSPerm := 0;
        end; (* case *)
    end; (* ICRPermToFSPerm *)

    function ICRBegin (var inst: ICRRecord; perm: ICPerm): ICError;
        var
            err: ICError;
            ref: integer;
            junk: OSErr;
    begin
        err := noErr;
        if (inst.perm <> icNoPerm) or (perm = icNoPerm) then begin
            err := paramErr;
        end; (* if *)
        if err = noErr then begin
            ICRCloseIfOpen(inst);                { ! }
            if not inst.have_config_file then begin
                err := bdNamErr;
            end; (* if *)
        end; (* if *)
        if err = noErr then begin
            ref := HOpenResFile(inst.config_file.vRefNum, inst.config_file.parID, inst.config_file.name, ICRPermToFSPerm(perm));
            err := ResError;
            if (err = fnfErr) or (err = eofErr) then begin
                case perm of
                    icReadOnlyPerm:  begin
                        ref := 0;
                        err := noErr;
                    end; (* icReadOnlyPerm *)
                    icReadWritePerm:  begin
                        junk := HCreate(inst.config_file.vRefNum, inst.config_file.parID, inst.config_file.name, ICcreator, ICfiletype);
                        HCreateResFile(inst.config_file.vRefNum, inst.config_file.parID, inst.config_file.name);
                        ref := HOpenResFile(inst.config_file.vRefNum, inst.config_file.parID, inst.config_file.name, ICRPermToFSPerm(perm));
                        err := ResError;
                    end; (* icReadWritePerm *)
                end; (* case *)
            end; (* if *)
        end; (* if *)
        if err = noErr then begin
            inst.config_refnum := ref;
            inst.perm := perm;
        end; (* if *)
        case err of
            opWrErr, permErr:
                err := icNoMoreWritersErr;
            otherwise { do nothing }
        end; (* case *)
        ICRBegin := err;
    end; (* ICRBegin *)

    function ICRCheckInside (var inst: ICRRecord): ICError;
    begin
        if inst.perm = icNoPerm then begin
            ICRCheckInside := paramErr;
        end
        else begin
            ICRCheckInside := noErr;
        end; (* if *)
    end; (* ICRCheckInside *)

    function ICRForceInside(var inst : ICRRecord; perm : ICPerm; var force_info : boolean) : ICError;
        var
            err : ICError;
    begin
        force_info := false;
        if (inst.perm = perm) or ((inst.perm = icReadWritePerm) and (perm = icReadOnlyPerm)) then begin
            err := noErr;
        end else if inst.perm = icNoPerm then begin
            err := ICRBegin(inst, perm);
            force_info := (err = noErr);
        end else begin
            err := icPermErr;
        end; (* if *)
        ICRForceInside := err;
    end; (* ICRForceInside *)

    function ICRReleaseInside(var inst : ICRRecord; force_info : boolean) : ICError;
    begin
        if force_info then begin
            ICRReleaseInside := ICREnd(inst);
        end else begin
            ICRReleaseInside := noErr;
        end; (* if *)
    end; (* ICRReleaseInside *)

    function ICRGetPref (var inst: ICRRecord; key: Str255; var attr: ICAttr; buf: Ptr; var size: longint): ICError;
        var
            err: ICError;
            err2 : ICError;
            max_size: longint;
            true_size: longint;
            old_refnum: integer;
            prefh: Handle;
            force_info : boolean;
    begin
        max_size := size;
        size := 0;
        attr := ICattr_no_change;
        prefh := nil;
        err := ICRForceInside(inst, icReadOnlyPerm, force_info);
        if (err = noErr) and (inst.config_refnum = 0) then begin
            err := icPrefNotFoundErr;
        end; (* if *)
        if (err = noErr) and ((key = '') or ((max_size < 0) and (buf <> nil))) then begin
            err := paramErr;
        end; (* if *)
        if err = noErr then begin
            old_refnum := CurResFile;
            UseResFile(inst.config_refnum);
            err := ResError;
            if err = noErr then begin
                prefh := Get1NamedResource(Res_Code, key);
                err := ResError;
                if prefh = nil then begin
                    err := icPrefNotFoundErr;
                end; (* if *)
                if err = noErr then begin
                    true_size := GetHandleSize(prefh);
                    if true_size < 4 then begin
                        err := icPrefDataErr;
                    end; (* if *)
                end; (* if *)
                if err = noErr then begin
                    size := true_size - 4;
                    attr := longintPtr(prefh^)^;
                    if (buf <> nil) and (size <> 0) then begin
                        if size > max_size then begin
                            err := icTruncatedErr;
                        end
                        else begin
                            max_size := size;
                        end; (* if *)
                        BlockMove(ptr(longint(prefh^) + 4), buf, max_size);
                    end; (* if *)
                end; (* if *)
                UseResFile(old_refnum);
            end; (* if *)
        end; (* if *)
        if prefh <> nil then begin
            ReleaseResource(prefh);
        end; (* if *)
        err2 := ICRReleaseInside(inst, force_info);
        if err = noErr then begin
            err := err2;
        end; (* if *)
        ICRGetPref := err;
    end; (* ICRGetPref *)

    function ICRSetPref (var inst: ICRRecord; key: Str255; attr: ICAttr; buf: Ptr; size: longint): ICError;
        var
            err: ICError;
            err2 : ICError;
            old_attr: longint;
            old_refnum: integer;
            prefh: Handle;
            id: integer;
            force_info : boolean;
    begin
        prefh := nil;
        if buf = nil then begin
            size := 0;
        end;
        err := ICRForceInside(inst, icReadWritePerm, force_info);
        if (err = noErr) and (inst.perm <> icReadWritePerm) then begin
            err := icPermErr;
        end; (* if *)
        if (err = noErr) and (inst.config_refnum = 0) then begin
            err := icInternalErr;
        end; (* if *)
        if (err = noErr) and ((key = '') or (size < 0)) then begin
            err := paramErr;
        end; (* if *)
        if err = noErr then begin
            old_refnum := CurResFile;
            UseResFile(inst.config_refnum);
            err := ResError;
            if err = noErr then begin
                prefh := Get1NamedResource(Res_Code, key);
                if (prefh <> nil) & (GetHandleSize(prefh) < 4) then begin { very bad! }
                    RmveResource(prefh);
                    DisposeHandle(prefh);
                    prefh := nil;
                end;
                if (prefh = nil) then begin
                    old_attr := 0;
                end
                else begin
                    old_attr := longintPtr(prefh^)^;
                end;
                if attr = ICattr_no_change then begin
                    attr := old_attr;
                end; (* if *)
                if btst(old_attr, ICattr_locked_bit) and btst(attr, ICattr_locked_bit) and (buf <> nil) then begin
                    err := icPermErr;
                end; (* if *)
                if (prefh = nil) then begin
                    prefh := NewHandle(size + 4);
                    err := MemError;
                    if err = noErr then begin
                        repeat
                            id := Unique1ID(Res_Code);
                        until id > 127;
                        AddResource(prefh, Res_Code, id, key);
                        err := ResError;
                        if err <> noErr then begin
                            DisposeHandle(prefh);
                            prefh := nil;
                        end; (* if *)
                    end; (* if *)
                end; (* if *)
                if (err = noErr) & (buf <> nil) then begin
                    SetHandleSize(prefh, size + 4);
                    err := MemError;
                end; (* if *)
                if (err = noErr) & (size > 0) then begin
                    BlockMove(buf, ptr(longint(prefh^) + 4), size);
                end; (* if *)
                if (err = noErr) then begin
                    longintPtr(prefh^)^ := attr;
                    ChangedResource(prefh);
                    WriteResource(prefh);
                    err := ResError;
                end; (* if *)
                UseResFile(old_refnum);
            end; (* if *)
        end; (* if *)
        if prefh <> nil then begin
            ReleaseResource(prefh);
        end; (* if *)
        err2 := ICRReleaseInside(inst, force_info);
        if err = noErr then begin
            err := err2;
        end; (* if *)
        ICRSetPref := err;
    end; (* ICRSetPref *)

    function ICRCountPref (var inst: ICRRecord; var count: longint): ICError;
        var
            err: ICError;
            old_refnum: integer;
    begin
        err := ICRCheckInside(inst);
        if (err = noErr) and (inst.config_refnum = 0) then begin
            count := 0;
        end
        else begin
            old_refnum := CurResFile;
            UseResFile(inst.config_refnum);
            err := ResError;
            if err = noErr then begin
                count := Count1Resources(Res_Code);
                err := ResError;
                UseResFile(old_refnum);
            end; (* if *)
        end; (* if *)
        if err <> noErr then begin
            count := 0;
        end; (* if *)
        ICRCountPref := err;
    end; (* ICRCountPref *)

    function ICRGetIndPref (var inst: ICRRecord; n: longint; var key: Str255): ICError;
        var
            err: ICError;
            old_refnum: integer;
            prefh: Handle;
            junk_id: integer;
            junk_type: ResType;
    begin
        prefh := nil;
        err := ICRCheckInside(inst);
        if (err = noErr) and (n < 1) then begin
            err := paramErr;
        end; (* if *)
        if (err = noErr) and (inst.config_refnum = 0) then begin
            err := icPrefNotFoundErr;
        end
        else begin
            old_refnum := CurResFile;
            UseResFile(inst.config_refnum);
            err := ResError;
            if err = noErr then begin
                SetResLoad(false);
                prefh := Get1IndResource(Res_Code, n);
                SetResLoad(true);
                if prefh = nil then begin
                    err := icPrefNotFoundErr;
                end
                else begin
                    GetResInfo(prefh, junk_id, junk_type, key);
                    err := ResError;
                end; (* if *)
                UseResFile(old_refnum);
            end; (* if *)
        end; (* if *)
        if prefh <> nil then begin
            ReleaseResource(prefh);
        end; (* if *)
        ICRGetIndPref := err;
    end; (* ICRGetIndPref *)

    function ICRDeletePref (var inst: ICRRecord; key: Str255): ICError;
        var
            err : ICError;
            prefh : Handle;
            old_refnum : integer;
    begin
        err := ICRCheckInside(inst);
        if (err = noErr) and (key = '') then begin
            err := paramErr;
        end; (* if *)
        if err = noErr then begin
            old_refnum := CurResFile;
            UseResFile(inst.config_refnum);
            err := ResError;
            if err = noErr then begin
                SetResLoad(false);
                prefh := Get1NamedResource(Res_Code, key);
                err := ResError;
                SetResLoad(true);
                if prefh = nil then begin
                    err := icPrefNotFoundErr;
                end; (* if *)
                if err = noErr then begin
                    RmveResource(prefh);
                    err := ResError;
                end; (* if *)
                UseResFile(old_refnum);
            end; (* if *)
        end; (* if *)
        ICRDeletePref := err;
    end; (* ICRDeletePref *)

    function ICREnd (var inst: ICRRecord): ICError;
        var
            err: ICError;
    begin
        err := ICRCheckInside(inst);
        ICRCloseIfOpen(inst);
        ICREnd := err;
    end; (* ICREnd *)

    function ICRDefaultFileName (var inst: ICRRecord; var name: Str63): ICError;
    begin
        name := ICdefault_file_name;
        ICRDefaultFileName := noErr;
    end; (* ICRDefaultFileName *)

end. (* ICRAPI *)